Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume12 / ffccc / part10 < prev next >

Wrap

Text File | 1990-05-14 | 47.2 KB | 1,439 lines

Newsgroups: comp.sources.misc organization: CERN, Geneva, Switzerland keywords: fortran subject: v12i096: Floppy - Fortran Coding Convention Checker Part 10/11 from: julian@cernvax.cern.ch (julian bunn) Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) Posting-number: Volume 12, Issue 96 Submitted-by: julian@cernvax.cern.ch (julian bunn) Archive-name: ffccc/part10 #!/bin/sh echo 'Start of Floppy, part 10 of 11:' echo 'x - BINSRC.f' sed 's/^X//' > BINSRC.f << '/' X SUBROUTINE BINSRC(KELEM,KLIST,NLIST,IPOS,LAST) X*----------------------------------------------------------------------- X* X*---Purpose: finds number in sorted list (ascending) X* with binary search. X* X*---Input X* KELEM number to be looked up X* KLIST table X* NLIST length of table X* X*---Output X* IPOS = 0: name not in table X* > 0: position in table X* LAST for IPOS=0, position behind which number belongs X* X*---Author : HG date: 17.5.79 last revision: 20.6.84 X* X*----------------------------------------------------------------------- X DIMENSION KLIST(*) X IPOS=0 X LAST=0 X N=NLIST X IF(N.GT.0) THEN X KPOS=0 X 10 M=(N+1)/2 X LAST=KPOS+M X IF (KELEM.LT.KLIST(LAST)) THEN X N=M X LAST=LAST-1 X IF (N.GT.1) GOTO 10 X ELSEIF (KELEM.GT.KLIST(LAST)) THEN X KPOS=LAST X N=N-M X IF (N.GT.0) GOTO 10 X ELSE X IPOS=LAST X ENDIF X ENDIF X END / echo 'x - CFLAGS.h' sed 's/^X//' > CFLAGS.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* +++++++++++++++++++++++++ action flags - as listed X* 1 make namelist/routine X* 2 make global namelist X* 3 print illegal statements X* 4 print changed statements X* 5 print filtered statements X* 6 print all statements X* 7 write changed statements only on output file X* 8 write filtered on output file X* 9 write all on output file X* 10 take first name only in statement X* 11 convert hollerith to quotes X* 12 string replacement requested X* 13 resequence statement numbers X* 14 FORMAT to end of routine X* 15 name replacements requested X* 16 routine filters given X* 17 class filters given X* 18 name filters given X* 19 string filters given X* 20 type variables X* 21 indent X* 22 USER command given X* 23 compressed output file requested X* 24 COMMON block option (signal unused and used C.B.) X* 25 print namelist / routine X* 26 print global namelist X* 27 print COMMON block and variable usage X* 28 adjust GOTO to the right X* 29 write tree output file on unit 13 X* +++++++++++++++++++++++++ status flags - as listed X* 1 no more lines on input X* 2 no more lines to process X* 3 illegal stmnt. detected in EXTRAC (unclosed string, or X* illegal character '{', '}' ). X* 4 end of program due to time limit X* 5 currently buffered routine without end (split) X* 6 currently buffered routine continuation (split) X* 7 current routine filtered X* 8 last filter passed X* 9 routine header still to be printed X* 10 statement still to be printed X* 11 statement cannot be changed (length overflow,or illegal repl.) X* 12 c.b. name list overflow in PROCOM, discard current routine X* 13 true when equiv. groups and commons have been merged (PROCOM) X* 14 true when current routine is a SUBROUTINE X*----------------------------------------------------------------------- X*EI / echo 'x - CHRTYP.f' sed 's/^X//' > CHRTYP.f << '/' X SUBROUTINE CHRTYP(ITYPE,STRING,ICC1,ICC2,HOLFLG,KPOS,ILEV) X*----------------------------------------------------------------------- X* returns first ch. of specified type, or 0 X* input X* ITYPE type X* 1 = numeric X* 2 = alpha X* 3 = alpha-numeric X* 4 = special X* 5 = FORTRAN-name X* string string to be looked up X* ICC1 first ch. in string X* ICC2 last ch. in string X* HOLFLG if TRUE, hollerith included in search X* output X* KPOS position of first ch. of specified type, or 0 X* ILEV relative level, including KPOS X* X*----------------------------------------------------------------------- X LOGICAL HOLFLG X CHARACTER STRING*(*),STEMP*1 X include 'CONVEX.h' X ILEV=0 X KPOS=0 X NCNT=0 X JC=ICC1-1 X 10 JC=JC+1 X IF (JC.GT.ICC2) GOTO 999 X STEMP=STRING(JC:JC) X IF(STEMP.EQ.'{') THEN X*--- start of character string X IF (.NOT.HOLFLG) THEN X I=INDEX(STRING(JC:ICC2),'}') X IF (I.EQ.0) GOTO 999 X JC=I+JC-1 X ENDIF X GOTO 10 X ELSEIF(STEMP.EQ.'}') THEN X GOTO 10 X ELSEIF(STEMP.EQ.'(') THEN X ILEV=ILEV+1 X ELSEIF(STEMP.EQ.')') THEN X ILEV=ILEV-1 X ENDIF X IF(ITYPE.EQ.1) THEN X IF (NUMCH(STEMP)) KPOS=JC X ELSEIF(ITYPE.EQ.2) THEN X IF (ALPHCH(STEMP)) KPOS=JC X ELSEIF(ITYPE.EQ.3) THEN X IF (ANUMCH(STEMP)) KPOS=JC X ELSEIF(ITYPE.EQ.4) THEN X IF (SPECCH(STEMP)) KPOS=JC X ELSEIF(ITYPE.EQ.5) THEN X IF (NCNT.EQ.0) THEN X IF (ALPHCH(STEMP)) THEN X KPOS=JC X NCNT=NCNT+1 X ENDIF X ELSEIF (ANUMCH(STEMP)) THEN X KPOS=JC X ENDIF X ENDIF X IF (KPOS.NE.JC) GOTO 10 X 999 END / echo 'x - CKEYCOM.h' sed 's/^X//' > CKEYCOM.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* NORSET = no. of OR-sets X* NGLSET = no. of global commands X* NKYNAM = no. of names in SKEYLS X* NKYSTR = no. of strings in SKYSTR X* LKYSTR = occupation of SKYSTR X* NKYCHR = no. of string refs in KSTREF X* NORCOM = no. of commands / OR-set X* KORCOM = start-1 of each OR-set in KEYREF X* KEYREF X* (I,1) = ref. number (=pos.) of key X* (I,2) = no. of integers in KEYINT X* (I,3) = start-1 of integers in KEYINT X* (I,4) = no. of names in SKEYLS X* (I,5) = start-1 of names in SKEYLS X* (I,6) = no. of string refs in KSTREF X* (I,7) = start-1 of string refs in KSTREF X* KEYINT = integer list for sub-keys etc. X* KNAMRF X* (I,1) = ref. to string following name, or zero if none, X* or < 0 if to be ignored (illegal) X* (I,2) = ref. to replacement string, or zero X* KSTREF X* (I,1) = ref. to string (stand alone), or < 0 if illegal X* (I,2) = ref. to replacement string for above, or zero X* KKYSTA = start of string in SKYSTR X* KKYEND = end of string in SKYSTR X* X* SKEYLS = name list for input commands X* SKYSTR = contains stand-alone or name-associated strings X*----------------------------------------------------------------------- X*EI / echo 'x - COMPAC.f' sed 's/^X//' > COMPAC.f << '/' X SUBROUTINE COMPAC(NUMBER) X*----------------------------------------------------------------------- X* X* extracts the FORTRAN field contents from the statement image. X* X*--- input X* NUMBER number of the statement to be extracted X* SIMA COMMON/ALCAZA/ (contains one complete routine) X* NLTYPE,NFLINE,NLLINE, COMMON/STATE/ X* X*--- output X* SSTA COMMON/ALCAZA/ FORTRAN fields 7-72 of SIMA X* NCHST COMMON/STATE/ last non-blank in SSTA X* or =0 if statement consists of comment lines only X* NLIMA, NLREF(1..NLIMA), /STATE/ X* X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'CURSTA.h' X include 'STATE.h' X NCHST=0 X NLIMA=0 X*--- find last non-blank (only last line) X JEND=LASTNB(SIMA(NLLINE(NUMBER)),8,72) X DO 10 JLINE=NFLINE(NUMBER),NLLINE(NUMBER) X IF (NLTYPE(JLINE).EQ.0) GOTO 10 X NLIMA=NLIMA+1 X NLREF(NLIMA)=JLINE X IF (JLINE.EQ.NLLINE(NUMBER)) THEN X JLAST=JEND X ELSE X JLAST=72 X ENDIF X L=JLAST-6 X SSTA(NCHST+1:NCHST+L)=SIMA(JLINE)(7:JLAST) X NCHST=NCHST+L X 10 CONTINUE X END / echo 'x - CPARAM.h' sed 's/^X//' > CPARAM.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X*--- MXNAME = dimension of IWS, COMMON/FLWORK/, and of SNAMES /ALCAZA/ X* MXSSTM = length of string SSTM, COMMON/ALCAZA/ X* MXSTAT = max. no. of statement definitions X* MCLASS = first dim. of ISTMDS( , ) = no. of control words/statement X* MXLENG = max. length of statement field (20*66) X* MXLINE = line length of input image X* MXSIMA = max. no. of lines in input image (one routine) X* MXSIMD = dim. of SIMA (excess for replacement overflows) X* MCUNIT = file for command input (data cards) X* MPUNIT = file for printed output X* MIUNIT = FORTRAN code input unit X* MTUNIT = TREE output unit X* MOUNIT = FORTRAN code output unit X* MXFLAG = no. of status and action flags X* MXNMCH = max. no. of characters per name X* MXORST = max. no. of OR-sets in control commands X* MDIMST = dimension of SSTA, SSTR, SKYSTR X* MGLOKY = no. of global command keys X* MLOCKY = no. of local (in each OR-set) command keys X* MSUBKY = no. of command sub-keys X* MXKINT = dim. of KEYINT /KEYINP/ X* MXKNAM = max. no. of names or strings on input commands (total) X* MXTYPE = max. no. of variable types X* MAXNUM = max. no. of statement numbers per routine X* MAXGRP = max. no. of c.b. names or equiv. groups (for ACTION(24)) X* TIMLIM = if less time left, refrain from reading next routine X* VERSIO = program version X* KALL = max. no. of different externals / routine (TREE) X* KENT = max. no. of ENTRY statements / routine (TREE) X* NOARG = max. no. of arguments / call (TREE) X*----------------------------------------------------------------------- X*EI / echo 'x - DEFINF.f' sed 's/^X//' > DEFINF.f << '/' X SUBROUTINE DEFINF X*----------------------------------------------------------------------- X* Define the table of FORTRAN intrinsic functions, and label the X* generic ones. X*----------------------------------------------------------------------- X include 'USINFN.h' X PARAMETER (NGEN=43) X CHARACTER*6 CINF(LIF) X CHARACTER*1 CGEN(NGEN) X INTEGER IGEN(NGEN) X DATA CINF/'INT ','IFIX ','IDINT ','IQINT ','REAL ','FLOAT ', X +'SNGL ','DBLE ','CMPLX ','ICHAR ','CHAR ','AINT ','DINT ', X +'ANINT ','DNINT ','NINT ','IDNINT','ABS ','IABS ','DABS ', X +'CABS ','MOD ','AMOD ','DMOD ','SIGN ','ISIGN ','DSIGN ', X +'DIM ','DDIM ','DPROD ','MAX ','MAX0 ','AMAX1 ','DMAX1 ', X +'AMAX0 ','MAX1 ','MIN ','MIN0 ','AMIN1 ','DMIN1 ','AMIN0 ', X +'MIN1 ','LEN ','INDEX ','IMAG ','AIMAG ','CONJG ','SQRT ', X +'DSQRT ','CSQRT ','EXP ','DEXP ','CEXP ','LOG ','ALOG ', X +'DLOG ','CLOG ','LOG10 ','ALOG10','DLOG10','SIN ','DSIN ', X +'CSIN ','COS ','DCOS ','CCOS ','TAN ','DTAN ','ASIN ', X +'DASIN ','ACOS ','DACOS ','ATAN ','DATAN ','ATAN2 ','DATAN2', X +'SINH ','DSINH ','COSH ','DCOSH ','TANH ','DTANH ','LGE ', X +'LGT ','LLE ','LLT ','QEXT ','DCMPLX','QCMPLX','CBRT ', X +'EXP2 ','EXP10 ','LOG2 ','COTAN ','ERF ','ERFC ','GAMMA ', X +'LGAMMA','IRE ','AMT ','NOT ','IAND ','IOR ','IEOR ', X +'ISHFT ','IBSET ','IBCLR ','BTEST ','REAL '/ X DATA IGEN /1,5,8,9,12,14,16,18,22,25,28,31,37,45,47,48,51,54,58, X & 61,64,67,69,71,73,75,77,79,81,87,88,89,90,91,92,93, X & 94,95,96,97,98,99,100/ X DATA CGEN /'I','R','D','K','R','R','I',6*'$','R','K',14*'$','D', X & 'D','K',9*'$','I','$'/ X DO 10 INF=1,LIF X CINFUN(INF) = CINF(INF) X INFUNG(INF) = 0 X 10 CONTINUE X DO 15 IG=1,NGEN X INFUNG(IGEN(IG)) = 1 X CTYFUN(IGEN(IG)) = CGEN(IG) X 15 CONTINUE X RETURN X END / echo 'x - EXTRAC.f' sed 's/^X//' > EXTRAC.f << '/' X SUBROUTINE EXTRAC(NUMBER,OPTION) X*----------------------------------------------------------------------- X* X* extracts the FORTRAN field contents from the statement image. X* holl. and character strings are included in special characters, X* '{' and '}'. strings may be either ...H, or be X* included in single or double quotes. X* X*--- input X* NUMBER number of the statement to be extracted X* OPTION (character) 'FULL' or 'PART' to extract X* all, or just start (up to first bracket) X* SIMA COMMON/ALCAZA/ (contains one complete routine) X* NLTYPE,ICLASS,NFLINE,NLLINE, COMMON/STATE/ X* X*--- output X* SSTA COMMON/ALCAZA/ FORTRAN fields 7-72 of SIMA X* NCHST COMMON/STATE/ last non-blank in SSTA X* or =0 if statement consists of comment lines only X* NLIMA, NLREF(1..NLIMA), /STATE/ X* STATUS(3) if illegal (containing '{', '}' ) X* X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'FLAGS.h' X include 'CURSTA.h' X include 'STATE.h' X CHARACTER OPTION*4 X NCHST=0 X NSTREF=0 X IF (NUMBER.LE.0.OR.NUMBER.GT.NSTAMM) GOTO 999 X IF (ICLASS(NUMBER,1).EQ.0) GOTO 999 X NSTREF=NUMBER X*--- compact statement into SSTA X CALL COMPAC(NUMBER) X IF (NCHST.EQ.0) GOTO 999 X*--- insert {} around strings, suppress multiple blanks X CALL MARKST(OPTION,IERR) X STATUS(3)=IERR.NE.0 X 999 END / echo 'x - FLINIT.f' sed 's/^X//' > FLINIT.f << '/' X SUBROUTINE FLINIT X*----------------------------------------------------------------------- X* X*--- initializes FLOP X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'CURSTA.h' X include 'FLAGS.h' X include 'JOBSUM.h' X include 'STATE.h' X include 'KEYCOM.h' X NSTBUF=0 X IGNAME=0 X NGNAME=0 X NKEEPL=0 X DO 10 I=1,10 X 10 NSTATC(I)=0 X DO 20 I=1,MXFLAG X ACTION(I)=.FALSE. X STATUS(I)=.FALSE. X 20 CONTINUE X NDUMMY=0 X NORSET=0 X NGLSET=0 X NKYINT=0 X NKYNAM=0 X NKYSTR=0 X NKYCHR=0 X*--- LKYSTR must start at one to leave room for an extra '#' X LKYSTR=1 X DO 30 I=1,MXORST X NORCOM(I)=0 X KORCOM(I)=0 X 30 CONTINUE X DO 40 I=1,7 X DO 40 J=1,MXKEYS X KEYREF(J,I)=0 X 40 CONTINUE X DO 50 I=1,2 X DO 50 J=1,MXKNAM X KNAMRF(J,I)=0 X KSTREF(J,I)=0 X 50 CONTINUE X DO 60 I=1,MXKINT X KEYINT(I)=0 X 60 CONTINUE X DO 70 I=1,2 X DO 70 J=1,MXSTAT X 70 NFDCLS(J,I)=0 X END / echo 'x - GETNAM.f' sed 's/^X//' > GETNAM.f << '/' X SUBROUTINE GETNAM(STRING,K1,K2,KFCH,KLCH) X*----------------------------------------------------------------------- X* X*--- finds one name at a time X* X*--- input X* STRING input string X* K1, K2 first and last ch. in STRING for scan X*--- output X* KFCH start of name in STRING, or 0 if none X* KLCH end of name in STRING X* X*----------------------------------------------------------------------- X CHARACTER STRING*(*), STEMP*1, SLAST*1 X LOGICAL STARTD,SKIP X include 'CONVEX.h' X SLAST=' ' X STARTD=.FALSE. X SKIP=.FALSE. X KNB=0 X KFCH=0 X JC=K1-1 X 10 JC=JC+1 X KLCH=KNB X IF (JC.GT.K2) GOTO 999 X STEMP=STRING(JC:JC) X*--- skip blanks X IF (STEMP.EQ.' ') GOTO 10 X IF(STEMP.EQ.'{') THEN X*--- start of string - quit or skip X IF (STARTD) GOTO 999 X I=INDEX(STRING(JC+1:K2),'}') X IF (I.EQ.0) GOTO 999 X JC=I+JC X GOTO 10 X ENDIF X KNB=JC X IF(SPECCH(STEMP)) THEN X IF (STARTD) GOTO 999 X*--- 'SKIP' helps to ignore .ge. etc X SKIP=STEMP.EQ.'.'.AND.(.NOT.SKIP.OR.SLAST.EQ.'.') X ELSEIF(ALPHCH(STEMP)) THEN X IF (.NOT.(SKIP.OR.NUMCH(SLAST))) THEN X*--- preceding if is to catch 1E3 etc X IF (.NOT.STARTD) KFCH=JC X STARTD=.TRUE. X ENDIF X ELSE X*--- numeric X SKIP=.FALSE. X*--- this is necessary for 1.E3 etc. X ENDIF X*--- keep last character X SLAST=STEMP X GOTO 10 X 999 END / echo 'x - GETOPT.f' sed 's/^X//' > GETOPT.f << '/' X SUBROUTINE GETOPT(SLINE,NLEN,SOPT,LOPT,IERR) XC find if character string SLINE is a recognised operator, and if so XC return that operator (minus any blanks) in SOPT. The operator does XC not need to necessarily fill the whole of SLINE. X PARAMETER (NOPER=22,LTEMP=100) X CHARACTER*(*) SLINE X CHARACTER*(LTEMP) STEMP X CHARACTER*6 SOPER(NOPER),SOPT X INTEGER LOPER(NOPER) XC all possible operators X DATA SOPER /'= ','( ',') ',', ',': ', X & '.EQV. ','.NEQV.','.OR. ','.AND. ','.NOT. ', X & '.GT. ','.GE. ','.LT. ','.LE. ','.EQ. ', X & '.NE. ','// ','+ ','- ','** ', X & '/ ','* '/ X DATA LOPER /1,1,1,1,1,5,6,4,5,5,4,4,4,4,4,4,2,1,1,2,1,1/ X NC = 0 XC loop over characters in the line segment and remove blanks X DO 10 I=1,NLEN X IF(SLINE(I:I).EQ.' ') GOTO 10 X NC = NC + 1 X STEMP(NC:NC) = SLINE(I:I) X 10 CONTINUE X IF(NC.EQ.0.OR.NC.GT.LTEMP) GOTO 900 XC find the operator. Note that ** is found correctly due to its order XC in the SOPER list. Similarly for // X DO 20 I=1,NOPER X IF(LOPER(I).GT.NC) GOTO 20 X IF(STEMP(:LOPER(I)).NE.SOPER(I)(:LOPER(I))) GOTO 20 X SOPT(:LOPER(I)) = SOPER(I)(:LOPER(I)) X LOPT = LOPER(I) X IERR = 0 X RETURN X 20 CONTINUE X 900 IERR = 1 X RETURN X END / echo 'x - INEXTR.f' sed 's/^X//' > INEXTR.f << '/' X SUBROUTINE INEXTR(SKEY,I1,I2,N) X*----------------------------------------------------------------------- X* compacts all occurrences of a given key in the range indicated, X* removes the key-words X* X* Input X* SKEY = key to look for X* I1 = start of input command range in SIMA X* I2 = end - - X* Output X* N = no. of characters in compacted string X* or -1 if key not found. X* SSTA, common /ALCAZA/ contains the string X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'STATE.h' X CHARACTER*3 SKEY X N=-1 X DO 20 I=I1,I2 X IF (SKEY.EQ.SIMA(NFLINE(I))(1:3)) THEN X*--- key found - skip key-word, string, replace ';' by ',' X IF (N.LT.0) N=0 X IS=NFLINE(I) X IL=NLLINE(I) X IP=NLTYPE(IL) X SIMA(IL)(IP:IP)=',' X IND=INDEX(SIMA(IS),',') X IF (IND.EQ.0.OR.IND.EQ.NLTYPE(IS)) THEN X KADD=1 X ELSE X KADD=0 X ENDIF X DO 10 J=IS+KADD,IL X IF (J.EQ.IS) THEN X IT=IND+1 X ELSE X IT=1 X ENDIF X L=NLTYPE(J)+1-IT X IF (N+L.GT.MDIMST) THEN X WRITE (MPUNIT,10000) SKEY,MDIMST X N=-1 X GOTO 999 X ENDIF X SSTA(N+1:N+L)=SIMA(J)(IT:NLTYPE(J)) X N=N+L X 10 CONTINUE X ENDIF X 20 CONTINUE X10000 FORMAT(/1X,8('*=*='),' WARNING - total length of key ', A, X +' more than ',I5,' characters, key ignored') X 999 END / echo 'x - INLINE.f' sed 's/^X//' > INLINE.f << '/' X SUBROUTINE INLINE(IUNIT,STRING,EOFFLG,NTYP) X*----------------------------------------------------------------------- X* X*--- reads one line from input X* X*--- input X* IUNIT logical unit number X*--- output X* STRING line read (up to MXLINE characters) X* EOFFLG TRUE when end of file X* NTYP type if line : 0 comment line X* 1 start of statement X* 2 contination line X* X*----------------------------------------------------------------------- X include 'PARAM.h' X CHARACTER STRING*(MXLINE),STEMP*1 X LOGICAL EOFFLG X include 'CONVEX.h' X EOFFLG=.FALSE. X READ (IUNIT,'(A)',END=40) STRING X DO 10 I=1,72 X IF (STRING(I:I).NE.' ') GOTO 20 X 10 CONTINUE X*--- all blank = comment X NTYP=0 X GOTO 999 X 20 CONTINUE X*--- check for comment X IF(I.LE.6) THEN X DO 30 J=I,5 X STEMP=STRING(J:J) X IF (.NOT.(STEMP.EQ.' '.OR.NUMCH(STEMP))) THEN X NTYP=0 X GOTO 999 X ENDIF X 30 CONTINUE X*--- not a comment line - check for continuation X STEMP=STRING(6:6) X IF (STEMP.EQ.' '.OR.STEMP.EQ.'0') THEN X NTYP=1 X ELSE X NTYP=2 X ENDIF X ELSE X NTYP=1 X ENDIF X GOTO 999 X 40 CONTINUE X EOFFLG=.TRUE. X 999 END / echo 'x - KEYCOM.h' sed 's/^X//' > KEYCOM.h << '/' X COMMON/KEYINP/NORSET,NGLSET,NKYINT,NKYNAM,NKYSTR,LKYSTR,NKYCHR, X 1 NORCOM(MXORST),KORCOM(MXORST),KEYREF(MXKEYS,7),KEYINT(MXKINT), X 2 KNAMRF(MXKNAM,2),KSTREF(MXKNAM,2),KKYSTA(MXKNAM),KKYEND(MXKNAM) X COMMON/SKEYNP/SKYSTR,SKEYLS(MXKNAM) X CHARACTER SKYSTR*(MDIMST),SKEYLS*(MXNMCH) X*IF DEF,NEVER X*----------------------------------------------------------------------- X* NORSET = no. of OR-sets X* NGLSET = no. of global commands X* NKYNAM = no. of names in SKEYLS X* NKYSTR = no. of strings in SKYSTR X* LKYSTR = occupation of SKYSTR X* NKYCHR = no. of string refs in KSTREF X* NORCOM = no. of commands / OR-set X* KORCOM = start-1 of each OR-set in KEYREF X* KEYREF X* (I,1) = ref. number (=pos.) of key X* (I,2) = no. of integers in KEYINT X* (I,3) = start-1 of integers in KEYINT X* (I,4) = no. of names in SKEYLS X* (I,5) = start-1 of names in SKEYLS X* (I,6) = no. of string refs in KSTREF X* (I,7) = start-1 of string refs in KSTREF X* KEYINT = integer list for sub-keys etc. X* KNAMRF X* (I,1) = ref. to string following name, or zero if none, X* or < 0 if to be ignored (illegal) X* (I,2) = ref. to replacement string, or zero X* KSTREF X* (I,1) = ref. to string (stand alone), or < 0 if illegal X* (I,2) = ref. to replacement string for above, or zero X* KKYSTA = start of string in SKYSTR X* KKYEND = end of string in SKYSTR X* X* SKEYLS = name list for input commands X* SKYSTR = contains stand-alone or name-associated strings X*----------------------------------------------------------------------- X*EI / echo 'x - LMERGE.f' sed 's/^X//' > LMERGE.f << '/' X SUBROUTINE LMERGE(SLIST,NACC,FLACC,IS,N1,N2) X*----------------------------------------------------------------------- X* X*--- merges two successive, alphabetically sorted lists X* in SLIST in place, updates NACC X* X*--- input X* SLIST list containing all names X* NACC array to be re-arranged with sort X* FLACC if true, NACC is actually updated X* IS start-1 of first list in IS X* N1 length of first list X* N2 length of second list X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'FLWORK.h' X CHARACTER *(MXNMCH) SLIST(*) X DIMENSION NACC(*) X LOGICAL FLACC X KADD=0 X K2=N1 X DO 20 I=1,N1 X II=I X 10 IF (K2.EQ.N1+N2) GOTO 40 X IF (SLIST(IS+I).GT.SLIST(IS+K2+1)) THEN X K2=K2+1 X IWS(K2)=I+KADD X KADD=KADD+1 X GOTO 10 X ELSE X IWS(I)=I+KADD X ENDIF X 20 CONTINUE X DO 30 I=K2+1,N1+N2 X 30 IWS(I)=I X GOTO 60 X 40 CONTINUE X DO 50 I=II,N1 X 50 IWS(I)=I+KADD X 60 CONTINUE X* X*--- put in place X* X CALL SHUFFL(SLIST,NACC,FLACC,IS,N1+N2) X END / echo 'x - NAMOVE.f' sed 's/^X//' > NAMOVE.f << '/' X SUBROUTINE NAMOVE(SLIST,K1,K2,N2) X*----------------------------------------------------------------------- X* X* moves a set of names from one place in a list to another X* X* Input X* SLIST table X* K1 start-1 of target position X* K2 start-1 of source position X* N2 number of names to move X* X* Output X* SLIST is rearranged X* X*----------------------------------------------------------------------- X include 'PARAM.h' X PARAMETER (MBUFF=200) X CHARACTER *(MXNMCH) SLIST(*),SBUFF(MBUFF) X N=N2 X KADD=K1 X K=K2 X NMOV=ABS(K1-K2) X 10 CONTINUE X NT=MIN(N,MBUFF) X DO 20 I=1,NT X SBUFF(I)=SLIST(K+I) X 20 CONTINUE X IF(K2.GT.K1) THEN X DO 30 I=K,K-NMOV+1,-1 X SLIST(NT+I)=SLIST(I) X 30 CONTINUE X DO 40 I=1,NT X SLIST(KADD+I)=SBUFF(I) X 40 CONTINUE X IF(NT.LT.N) THEN X N=N-NT X K=K+NT X KADD=KADD+NT X GOTO 10 X ENDIF X ELSEIF(K2.LT.K1) THEN X NMOV=NMOV-NT X KADD=K1-NT X DO 50 I=K2+1,K2+NMOV X SLIST(I)=SLIST(NT+I) X 50 CONTINUE X DO 60 I=1,NT X SLIST(KADD+I)=SBUFF(I) X 60 CONTINUE X IF(NT.LT.N) THEN X N=N-NT X NMOV=NMOV+NT X GOTO 10 X ENDIF X ENDIF X END / echo 'x - NAMTAB.f' sed 's/^X//' > NAMTAB.f << '/' X SUBROUTINE NAMTAB(SNAME,SLIST,NLIST,IPOS) X*----------------------------------------------------------------------- X* X* enters a name in an alphabetic table, or gives position if already in. X* X* input X* SNAME name to be entered X* SLIST name list X* NUMTAB reference list to be updated (integers) X* NLIST no. of names in SLIST X* Output X* IPOS <0: -pos of name already in table X* =0: NLIST <0 X* >0: pos of newly entered name in table X* X*+++++++++++ IMPORTANT X* In case the name has been entered, the user must increase the list X* length himself. X*----------------------------------------------------------------------- X CHARACTER *(*) SNAME,SLIST(*) X IF(NLIST.LT.0) THEN X IPOS=0 X ELSEIF(NLIST.EQ.0) THEN X IPOS=1 X SLIST(1)=SNAME X ELSE X CALL NAMSRC(SNAME,SLIST,NLIST,KPOS,LAST) X IF (KPOS.EQ.0) THEN X*--- name not yet in table X IPOS=LAST+1 X DO 10 I=NLIST,IPOS,-1 X SLIST(I+1)=SLIST(I) X 10 CONTINUE X SLIST(IPOS)=SNAME X ELSE X IPOS=-KPOS X ENDIF X ENDIF X END / echo 'x - OPRSLT.f' sed 's/^X//' > OPRSLT.f << '/' X SUBROUTINE OPRSLT(STYP1,SOPER,STYP2,IERR,SRSLT) XC! Get the type of an operator result XC XC for a given pair of operands, with a given operator, XC returns the type of the result, and indicates whether XC expression was mixed mode by IERR=0 (not mixed), XC IERR=1 (mixed). XC X CHARACTER*6 SOPER X CHARACTER*1 STYP1,STYP2,SRSLT XC XC throw out SOME operators XC X IF(SOPER(:1).EQ.'*'.OR. X & SOPER(:1).EQ.'/'.OR.SOPER(:1).EQ.'+'.OR. X & SOPER(:1).EQ.'-') GOTO 5 X IERR = 0 X SRSLT=STYP1 X GOTO 999 X 5 CONTINUE XC X SRSLT = ' ' X IF(STYP1.EQ.'I') THEN XC INTEGER 1 X IF(STYP2.EQ.'I') SRSLT='I' X IF(STYP2.EQ.'R') SRSLT='R' X IF(STYP2.EQ.'D') SRSLT='D' X IF(STYP2.EQ.'K') SRSLT='K' X ELSE IF(STYP1.EQ.'R') THEN XC REAL 1 X IF(STYP2.EQ.'I') SRSLT='R' X IF(STYP2.EQ.'R') SRSLT='R' X IF(STYP2.EQ.'D') SRSLT='D' X IF(STYP2.EQ.'K') SRSLT='K' X ELSE IF(STYP1.EQ.'D') THEN XC DOUBLE PRECISION X IF(STYP2.EQ.'I') SRSLT='D' X IF(STYP2.EQ.'R') SRSLT='D' X IF(STYP2.EQ.'D') SRSLT='D' X ELSE IF(STYP1.EQ.'K') THEN XC COMPLEX X IF(STYP2.EQ.'I') SRSLT='K' X IF(STYP2.EQ.'R') SRSLT='K' X IF(STYP2.EQ.'K') SRSLT='K' X ENDIF X IF(SRSLT.EQ.' ') THEN XC UNRECOGNISED TYPE X SRSLT='$' X IERR = 0 X GOTO 999 X ENDIF XC CHECK FOR EXPONENTIATION X IF(SOPER(:2).EQ.'**') THEN X SRSLT = STYP1 X IERR = 0 X GOTO 999 X ENDIF XC CHECK FOR MIXED MODE X IF(STYP1.NE.STYP2) THEN X IERR = 1 X GOTO 999 X ENDIF X IERR = 0 X 999 CONTINUE X RETURN X END / echo 'x - POSCH.f' sed 's/^X//' > POSCH.f << '/' X SUBROUTINE POSCH(SFIND,STRING,ICC1,ICC2,HOLFLG,MLEV,KPOS,ILEV) X*----------------------------------------------------------------------- X* positions on a specified character X* input X* SFIND character looked for X* STRING string to be looked up X* ICC1 first ch. in LSTRNG X* ICC2 last ch. - X* HOLFLG if TRUE, hollerith included X* MLEV max. level allowed for character (relative to ICC1...ICC2) X* output X* KPOS position of ICOMP in LSTRNG, or 0 X* ILEV relative level, including KPOS X*----------------------------------------------------------------------- X LOGICAL HOLFLG X CHARACTER STRING*(*),SFIND*1,STEMP*1 X ILEV=0 X KPOS=0 X JC=ICC1-1 X 10 JC=JC+1 X IF (JC.GT.ICC2) GOTO 999 X STEMP=STRING(JC:JC) X IF(STEMP.EQ.'(') THEN X ILEV=ILEV+1 X ELSEIF(STEMP.EQ.')') THEN X ILEV=ILEV-1 X ENDIF X IF(STEMP.EQ.SFIND.AND.ILEV.LE.MLEV) THEN X KPOS=JC X GOTO 999 X ENDIF X IF(STEMP.EQ.'{') THEN X*--- start of character string X IF (.NOT.HOLFLG) THEN X I=INDEX(STRING(JC:ICC2),'}') X IF (I.EQ.0) GOTO 999 X JC=I+JC-1 X ENDIF X ENDIF X GOTO 10 X 999 END / echo 'x - PROIND.f' sed 's/^X//' > PROIND.f << '/' X SUBROUTINE PROIND X*----------------------------------------------------------------------- X* X* Prepares indentation by updating current DO and IF levels X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'CLASS.h' X include 'CURSTA.h' X include 'STATE.h' X DIMENSION IDO(100) X SAVE IDO X*--- get external class number X ICLEXT=ISTMDS(6,ICURCL(1)) X IF(ICLEXT.EQ.33) THEN X*--- FORMAT, do not indent X INDCNT=0 X GOTO 999 X ELSE X INDCNT=KNTDO+KNTIF X ENDIF X IF(ICLEXT.EQ.39) THEN X*--- IF...THEN X KNTIF=KNTIF+1 X ELSEIF(ICLEXT.EQ.23.OR.ICLEXT.EQ.24) THEN X*--- ELSE or ELSEIF X INDCNT=INDCNT-1 X ELSEIF(ICLEXT.EQ.27) THEN X*--- ENDIF X KNTIF=KNTIF-1 X INDCNT=INDCNT-1 X ELSEIF(ICLEXT.EQ.20) THEN X*--- DO loop X IF (KNTDO.LT.100) THEN X KNTDO=KNTDO+1 X CALL GETINT(SSTA,1,NCHST,KFCH,KLCH,NN) X IDO(KNTDO)=NN X ENDIF X ELSEIF(KNTDO.GT.0) THEN X*--- check for (possibly multiple) end of DO loop X K=NEXTIN(SIMA(NFLINE(NSTREF)),1,5) X KST=KNTDO X DO 10 I=KST,1,-1 X IF (IDO(I).NE.K) GOTO 20 X KNTDO=KNTDO-1 X INDCNT=INDCNT-1 X 10 CONTINUE X 20 CONTINUE X ENDIF X INDCNT=MAX(0,INDCNT) X 999 END / echo 'x - READSB.f' sed 's/^X//' > READSB.f << '/' X SUBROUTINE READSB(NCOMM,NST,ICL) X*----------------------------------------------------------------------- X* X* Purpose: performs sub-task for READEC by accepting the start of X* a new FORTRAN statement. X* X* Input: NCOMM number of comment lines preceding the new line X* X* Output: NST no. of last FORTRAN statement X* ICL class of last FORTRAN statement X* X* Various variables in common are used and modified. X* X* Author : HG date: 7.9.84 last revision: 7.9.84 X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'CURSTA.h' X include 'STATE.h' X NST=0 X IF(NSTAMM.GT.0) THEN X*--- close previous if FORTRAN X IF (NLTYPE(NFLINE(NSTAMM)).EQ.1) THEN X NLLINE(NSTAMM)=NLINES-NCOMM X NFSTAT=NFSTAT+1 X ICLASS(NSTAMM,1)=999 X NST=NSTAMM X CALL EXTRAC(NSTAMM,'PART') X CALL CLASSF X ICL=ICURCL(1) X ENDIF X ENDIF X IF(NCOMM.GT.0) THEN X*--- make comment line blocks into one statement X NSTAMM=NSTAMM+1 X NFLINE(NSTAMM)=NLINES-NCOMM+1 X NLLINE(NSTAMM)=NLINES X ICLASS(NSTAMM,1)=0 X NCOMM=0 X ENDIF X END / echo 'x - REPSUB.f' sed 's/^X//' > REPSUB.f << '/' X SUBROUTINE REPSUB(KREF1,KREF2,NSPEC,KSP1,KSP2,NCH) X*----------------------------------------------------------------------- X* X* Sub-task of inserting the replacement string (for REPNAM, REPSTR) X* X*--- Input X* KREF1 ref. to string to be replaced (cf. KKYSTA, KKYEND) X* KREF2 ref. to replacement string X* NSPEC no. of special symbols in STR1 X* KSP1, KSP2 start and end of special symbol matches in STR1 X*---Input/Output X* NCH occupation of NCH before and after replacement X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'KEYCOM.h' X include 'FLWORK.h' X DIMENSION KSP1(*),KSP2(*) X DIMENSION ICT(10),ICT1(10),ICT2(10),IREF1(MXNAME/20,10), IREF2 X +(MXNAME/20,10) X EQUIVALENCE (IREF1(1,1),IWS(1)),(IREF2(1,1),IWS(MXNAME/2+1)) X CHARACTER STEMP*1 X LOGICAL SKIPFL X include 'CONVEX.h' X CALL SPECCT(1,KREF1,NTOT1,ICT1,IREF1,IERR) X CALL SPECCT(2,KREF2,NTOT2,ICT2,IREF2,IERR) X SKIPFL=.FALSE. X DO 10 I=1,10 X ICT(I)=0 X 10 CONTINUE X INSTR=0 X DO 30 I=KKYSTA(KREF2),KKYEND(KREF2) X STEMP=SKYSTR(I:I) X IF (SKIPFL) GOTO 20 X IF (STEMP.EQ.'''') INSTR=1-INSTR X IN=INDEX(SPCHAR,STEMP) X IF (IN.EQ.0.OR.INSTR.NE.0) THEN X*--- normal character X NCH=NCH+1 X IF (NCH.GT.MXLENG) GOTO 999 X SSTR(NCH:NCH)=STEMP X ELSE X*--- count X ICT(IN)=ICT(IN)+1 X*--- get count in [...], or default X N=IREF2(ICT(IN),IN) X K=IREF1(N,IN) X L=KSP2(K)-KSP1(K)+1 X IF (L.GT.0) THEN X IF (NCH+L.GT.MXLENG) THEN X NCH=MXLENG+1 X GOTO 999 X ENDIF X SSTR(NCH+1:NCH+L)=SSTA(KSP1(K):KSP2(K)) X NCH=NCH+L X SKIPFL=SKYSTR(I+1:I+1).EQ.'[' X ENDIF X ENDIF X GOTO 30 X 20 CONTINUE X SKIPFL=STEMP.NE.']' X 30 CONTINUE X 999 END / echo 'x - SHUFFL.f' sed 's/^X//' > SHUFFL.f << '/' X SUBROUTINE SHUFFL(SLIST,NACC,FLACC,IS,NS) X*----------------------------------------------------------------------- X* X*--- puts the names in a list in the order given in an array. X* Updates NACC. X* X*--- input X* SLIST list containing all names X* NACC array to be re-arranged with sort X* FLACC if true, NACC is actually updated X* IS start-1 of list in SLIST X* NS # of elements X* IWS array containing for element I its target place L, X* /FLWORK/ X* ++++++++ warning +++++++++++ IWS is destroyed +++++++++++++++ X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'FLWORK.h' X CHARACTER *(MXNMCH) SLIST(*), SW(2) X DIMENSION KEEP(2),NACC(*) X LOGICAL STD,FLACC X K=1 X I=1 X 10 STD=.TRUE. X 20 CONTINUE X L=IWS(I) X IF(L.EQ.I) THEN X IWS(I)=0 X I=I+1 X IF (I.LE.NS) GOTO 10 X ELSEIF(L.GT.0) THEN X IF (STD) THEN X SW(K)=SLIST(IS+I) X IF(FLACC) KEEP(K)=NACC(IS+I) X STD=.FALSE. X ENDIF X SW(3-K)=SLIST(IS+L) X IF(FLACC) KEEP(3-K)=NACC(IS+L) X SLIST(IS+L)=SW(K) X IF(FLACC) NACC(IS+L)=KEEP(K) X K=3-K X IWS(I)=0 X I=L X GOTO 20 X ELSE X*--- look for new non-zero element to start with X DO 30 I=1,NS X IF (IWS(I).GT.0) GOTO 10 X 30 CONTINUE X ENDIF X END / echo 'x - SKIPLV.f' sed 's/^X//' > SKIPLV.f << '/' X SUBROUTINE SKIPLV(STRING,ICC1,ICC2,HOLFLG,KPOS,ILEV) X*----------------------------------------------------------------------- X* scans back to right bracket corresponding to last left one X* input X* STRING string to be looked up X* ICC1 first ch. in LSTRNG X* ICC2 last ch. - X* HOLFLG if TRUE, hollerith included X* output X* KPOS position of right bracket or 0 X* ILEV relative level, including KPOS (i.e. -1, if found) X*----------------------------------------------------------------------- X LOGICAL HOLFLG X CHARACTER STRING*(*),STEMP*1 X ILEV=0 X KPOS=0 X JC=ICC1-1 X 10 JC=JC+1 X IF (JC.GT.ICC2) GOTO 999 X STEMP=STRING(JC:JC) X IF(STEMP.EQ.'{') THEN X*--- start of character string X IF (.NOT.HOLFLG) THEN X I=INDEX(STRING(JC:ICC2),'}') X IF (I.EQ.0) GOTO 999 X JC=I+JC-1 X ENDIF X ELSEIF(STEMP.EQ.'(') THEN X ILEV=ILEV+1 X ELSEIF(STEMP.EQ.')') THEN X ILEV=ILEV-1 X IF (ILEV.LT.0) GOTO 20 X ENDIF X GOTO 10 X 20 CONTINUE X KPOS=JC X 999 END / echo 'x - SUMMRY.f' sed 's/^X//' > SUMMRY.f << '/' X SUBROUTINE SUMMRY X*----------------------------------------------------------------------- X* X*--- Prints job summary X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'JOBSUM.h' X include 'STATE.h' X include 'FLAGS.h' X IF(ACTION(26).AND.NGNAME.GT.0) THEN X*--- print list of global names first XC WRITE (MPUNIT,10000) NGNAME X IF (ACTION(20)) THEN X*--- print name list with types XC CALL PRNAMF(IGNAME+1,IGNAME+NGNAME) X ELSE XC WRITE (MPUNIT,10010) (SNAMES(IGNAME+J),J=1,NGNAME) X ENDIF X ENDIF XC CALL STSUMM X IF(.NOT.STATUS(2)) THEN XC WRITE (MPUNIT,10020) X ENDIF X IF(STATUS(4)) THEN XC WRITE (MPUNIT,10030) X ENDIF X WRITE (MPUNIT,10040) X WRITE (MPUNIT,10050) (NSTATC(J),J=1,8) X10000 FORMAT(//' Global list of',I6,' names'/) X10010 FORMAT(1X,10A10) X10020 FORMAT(//1X,10('*=*='),' WARNING - EOF not reached on input') X10030 FORMAT(//1X,10('*=*='),' WARNING - ending job at time limit') X10040 FORMAT(//1X,10('****'),' Job Summary ',10('****')) X10050 FORMAT(' no. of lines read =',I10/ X +' no. of lines out =',I10/ X +' no. of statements =',I10/ X +' no. of filtered stmts. =',I10/ X +' no. of changed stmts. =',I10/ X +' no. of stmts. unable to change =',I10/ X +' no. of comment lines =',I10/ X +' no. of lines printed =',I10) X10060 FORMAT(/' time (sec) =',F10.3/ X +' time per statement(msec)=',F10.3) X END / echo 'x - SUPMOR.f' sed 's/^X//' > SUPMOR.f << '/' X SUBROUTINE SUPMOR(SLIST,NACC,FLACC,IS,NS,NOUT) X*----------------------------------------------------------------------- X* X*--- suppresses multiple entries in sorted table, logically ORs NAMTYP X* X*--- input X* SLIST list containing all names X* NACC array to be re-arranged, and logically ORed X* FLACC if true, NACC is actually updated X* IS start-1 of table in SNAMES, /ALCAZA/ X* NS length of table X*--- output X* NOUT new table length X* X*----------------------------------------------------------------------- X include 'PARAM.h' X CHARACTER *(MXNMCH) SLIST(*) X DIMENSION NACC(*) X LOGICAL FLACC X NQ=NS X IF (NQ.LE.0) THEN X NOUT=0 X ELSE X NOUT=1 X DO 10 I=2,NQ X IF (SLIST(IS+I).NE.SLIST(IS+NOUT)) THEN X NOUT=NOUT+1 X IF (I.NE.NOUT) THEN X SLIST(IS+NOUT)=SLIST(IS+I) X IF(FLACC) NACC(IS+NOUT)=NACC(IS+I) X ENDIF X ELSEIF(FLACC) THEN X NACC(IS+NOUT)=IOR(NACC(IS+NOUT),NACC(IS+I)) X ENDIF X 10 CONTINUE X ENDIF X END / echo 'x - SUPMUL.f' sed 's/^X//' > SUPMUL.f << '/' X SUBROUTINE SUPMUL(SLIST,NACC,FLACC,IS,NS,NOUT) X*----------------------------------------------------------------------- X* X*--- suppresses multiple entries in sorted table, update NAMTYP X* X*--- input X* SLIST list containing all names X* NACC array to be re-arranged with sort X* FLACC if true, NACC is actually updated X* IS start-1 of table in SNAMES, /ALCAZA/ X* NS length of table X*--- output X* NOUT new table length X* X*----------------------------------------------------------------------- X include 'PARAM.h' X CHARACTER *(MXNMCH) SLIST(*) X DIMENSION NACC(*) X LOGICAL FLACC X NQ=NS X IF (NQ.LE.0) THEN X NOUT=0 X ELSE X NOUT=1 X DO 10 I=2,NQ X IF (SLIST(IS+I).NE.SLIST(IS+NOUT)) THEN X NOUT=NOUT+1 X IF (I.NE.NOUT) THEN X SLIST(IS+NOUT)=SLIST(IS+I) X IF(FLACC) NACC(IS+NOUT)=NACC(IS+I) X ENDIF X ENDIF X 10 CONTINUE X ENDIF X END / echo 'x - TY2TYP.f' sed 's/^X//' > TY2TYP.f << '/' X SUBROUTINE TY2TYP(ISN,STYP) XC! Reduces types of operand to smaller set X include 'PARAM.h' X include 'ALCAZA.h' X include 'CLASS.h' X include 'STATE.h' X include 'USINFN.h' X LOGICAL BTEST XC XC Here we attempt to evaluate the type of a FLOP statement XC 'name' using e.g. generic intrinsic function rules etc. XC X CHARACTER*(*) STYP X CHARACTER*1 STYPE(7) XC I=integer R=real D=doubleprecision K=complex L=logical C=complex $=aaargh! X DATA STYPE /'I','R','D','K','L','C','$'/ X STYP = STYPE(7) X DO 10 IR=1,NRNAME X IF(SNAMES(ISN+ISNAME).NE.SNAMES(IR+IRNAME)) GOTO 10 X NTYP = NAMTYP(IR+IRNAME) XC check for generic intrinsic function X IF(BTEST(NTYP,16)) THEN XC marked as a function X IFOUN = 0 X LEN = INDEX(SNAMES(IR+IRNAME),' ')-1 X DO 20 INFUN=1,LIF X IF(CINFUN(INFUN)(:LEN).NE.SNAMES(IR+IRNAME)(:LEN)) GOTO 20 X IF(INFUNG(INFUN).EQ.0) GOTO 20 XC generic function X IFOUN = INFUN X 20 CONTINUE X IF(IFOUN.NE.0) THEN XC? is this correct ? X STYP = CTYFUN(IFOUN) X RETURN X ENDIF X ENDIF X IF(BTEST(NTYP,0)) THEN X STYP = STYPE(1) X RETURN X ELSE IF(BTEST(NTYP,1)) THEN X STYP = STYPE(2) X RETURN X ELSE IF(BTEST(NTYP,3)) THEN X STYP = STYPE(4) X RETURN X ELSE IF(BTEST(NTYP,4)) THEN X STYP = STYPE(3) X RETURN X ELSE IF(BTEST(NTYP,2)) THEN X STYP = STYPE(5) X RETURN X ELSE IF(BTEST(NTYP,5)) THEN X STYP = STYPE(6) X RETURN X ENDIF X RETURN X 10 CONTINUE X RETURN X END / echo 'x - floppy.vmscld' sed 's/^X//' > floppy.vmscld << '/' X DEFINE VERB FLOPPY X IMAGE "CERN$CERNEXE:FLOPPY.EXE" X PARAMETER P1,PROMPT="Input FORTRAN file", VALUE(TYPE=$FILE, REQUIRED) X QUALIFIER OLD, VALUE(TYPE=$FILE) X QUALIFIER CHECKS, VALUE(LIST,TYPE=$NUMBER),DEFAULT X QUALIFIER FORTRAN, VALUE(TYPE=$FILE,DEFAULT="FORTRAN.FOR") X QUALIFIER OUTPUT, VALUE(TYPE=$FILE), BATCH X QUALIFIER LOG, DEFAULT X QUALIFIER SPECIAL, VALUE(TYPE=NAMES,DEFAULT="STANDARD"),NONNEGATABLE X QUALIFIER IGNORE, VALUE(LIST), NONNEGATABLE X QUALIFIER FULL, NONNEGATABLE X QUALIFIER TREE, NONNEGATABLE X QUALIFIER TIDY, NONNEGATABLE X QUALIFIER INDENT, VALUE(TYPE=$NUMBER,DEFAULT="3"), NONNEGATABLE X QUALIFIER GROUPF, NONNEGATABLE X QUALIFIER FORMAT, VALUE(LIST,TYPE=RANGE,REQUIRED), NONNEGATABLE X QUALIFIER STMNTS, VALUE(LIST,TYPE=RANGE,REQUIRED), NONNEGATABLE X QUALIFIER GOTOS, NONNEGATABLE X DISALLOW SPECIAL AND CHECKS X DISALLOW ((OLD OR OUTPUT OR FULL OR SPECIAL OR IGNORE) AND NEG CHECKS) X DISALLOW TIDY AND NOT (FORTRAN OR INDENT OR GROUPF OR FORMAT OR STMNTS OR GOTOS) X DISALLOW (FORMAT.STEP AND NOT FORMAT.START) X DISALLOW (FORMAT.START AND NOT FORMAT.STEP) X DISALLOW (STMNTS.STEP AND NOT STMNTS.START) X DISALLOW (STMNTS.START AND NOT STMNTS.STEP) X DISALLOW (FORTRAN OR INDENT OR GROUPF OR FORMAT OR STMNTS OR GOTOS) AND NOT TIDY XDEFINE TYPE NAMES X KEYWORD STANDARD, DEFAULT X KEYWORD ALEPH X KEYWORD GALEPH X KEYWORD ONLINE XDEFINE TYPE RANGE X KEYWORD START, VALUE(TYPE=$NUMBER) X KEYWORD STEP, VALUE(TYPE=$NUMBER) / echo 'Part 10 of Floppy complete.' exit